home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Module / Build / Notes.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  7.5 KB  |  296 lines
  1. package Module::Build::Notes;
  2.  
  3. # A class for persistent hashes
  4.  
  5. use strict;
  6. use vars qw($VERSION);
  7. $VERSION = '0.2808_01';
  8. $VERSION = eval $VERSION;
  9. use Data::Dumper;
  10. use IO::File;
  11. use Module::Build::Dumper;
  12.  
  13. sub new {
  14.   my ($class, %args) = @_;
  15.   my $file = delete $args{file} or die "Missing required parameter 'file' to new()";
  16.   my $self = bless {
  17.             disk => {},
  18.             new  => {},
  19.             file => $file,
  20.             %args,
  21.            }, $class;
  22. }
  23.  
  24. sub restore {
  25.   my $self = shift;
  26.  
  27.   my $fh = IO::File->new("< $self->{file}") or die "Can't read $self->{file}: $!";
  28.   $self->{disk} = eval do {local $/; <$fh>};
  29.   die $@ if $@;
  30.   $self->{new} = {};
  31. }
  32.  
  33. sub access {
  34.   my $self = shift;
  35.   return $self->read() unless @_;
  36.   
  37.   my $key = shift;
  38.   return $self->read($key) unless @_;
  39.   
  40.   my $value = shift;
  41.   $self->write({ $key => $value });
  42.   return $self->read($key);
  43. }
  44.  
  45. sub has_data {
  46.   my $self = shift;
  47.   return keys %{$self->read()} > 0;
  48. }
  49.  
  50. sub exists {
  51.   my ($self, $key) = @_;
  52.   return exists($self->{new}{$key}) || exists($self->{disk}{$key});
  53. }
  54.  
  55. sub read {
  56.   my $self = shift;
  57.  
  58.   if (@_) {
  59.     # Return 1 key as a scalar
  60.     my $key = shift;
  61.     return $self->{new}{$key} if exists $self->{new}{$key};
  62.     return $self->{disk}{$key};
  63.   }
  64.    
  65.   # Return all data
  66.   my $out = (keys %{$self->{new}}
  67.          ? {%{$self->{disk}}, %{$self->{new}}}
  68.          : $self->{disk});
  69.   return wantarray ? %$out : $out;
  70. }
  71.  
  72. sub _same {
  73.   my ($self, $x, $y) = @_;
  74.   return 1 if !defined($x) and !defined($y);
  75.   return 0 if !defined($x) or  !defined($y);
  76.   return $x eq $y;
  77. }
  78.  
  79. sub write {
  80.   my ($self, $href) = @_;
  81.   $href ||= {};
  82.   
  83.   @{$self->{new}}{ keys %$href } = values %$href;  # Merge
  84.  
  85.   # Do some optimization to avoid unnecessary writes
  86.   foreach my $key (keys %{ $self->{new} }) {
  87.     next if ref $self->{new}{$key};
  88.     next if ref $self->{disk}{$key} or !exists $self->{disk}{$key};
  89.     delete $self->{new}{$key} if $self->_same($self->{new}{$key}, $self->{disk}{$key});
  90.   }
  91.   
  92.   if (my $file = $self->{file}) {
  93.     my ($vol, $dir, $base) = File::Spec->splitpath($file);
  94.     $dir = File::Spec->catpath($vol, $dir, '');
  95.     return unless -e $dir && -d $dir;  # The user needs to arrange for this
  96.  
  97.     return if -e $file and !keys %{ $self->{new} };  # Nothing to do
  98.     
  99.     @{$self->{disk}}{ keys %{$self->{new}} } = values %{$self->{new}};  # Merge 
  100.     $self->_dump($file, $self->{disk});
  101.    
  102.     $self->{new} = {};
  103.   }
  104.   return $self->read;
  105. }
  106.  
  107. sub _dump {
  108.   my ($self, $file, $data) = @_;
  109.   
  110.   my $fh = IO::File->new("> $file") or die "Can't create '$file': $!";
  111.   print {$fh} Module::Build::Dumper->_data_dump($data);
  112. }
  113.  
  114. sub write_config_data {
  115.   my ($self, %args) = @_;
  116.  
  117.   my $fh = IO::File->new("> $args{file}") or die "Can't create '$args{file}': $!";
  118.  
  119.   printf $fh <<'EOF', $args{config_module};
  120. package %s;
  121. use strict;
  122. my $arrayref = eval do {local $/; <DATA>}
  123.   or die "Couldn't load ConfigData data: $@";
  124. close DATA;
  125. my ($config, $features, $auto_features) = @$arrayref;
  126.  
  127. sub config { $config->{$_[1]} }
  128.  
  129. sub set_config { $config->{$_[1]} = $_[2] }
  130. sub set_feature { $features->{$_[1]} = 0+!!$_[2] }  # Constrain to 1 or 0
  131.  
  132. sub auto_feature_names { grep !exists $features->{$_}, keys %%$auto_features }
  133.  
  134. sub feature_names {
  135.   my @features = (keys %%$features, auto_feature_names());
  136.   @features;
  137. }
  138.  
  139. sub config_names  { keys %%$config }
  140.  
  141. sub write {
  142.   my $me = __FILE__;
  143.   require IO::File;
  144.  
  145.   # Can't use Module::Build::Dumper here because M::B is only a
  146.   # build-time prereq of this module
  147.   require Data::Dumper;
  148.  
  149.   my $mode_orig = (stat $me)[2] & 07777;
  150.   chmod($mode_orig | 0222, $me); # Make it writeable
  151.   my $fh = IO::File->new($me, 'r+') or die "Can't rewrite $me: $!";
  152.   seek($fh, 0, 0);
  153.   while (<$fh>) {
  154.     last if /^__DATA__$/;
  155.   }
  156.   die "Couldn't find __DATA__ token in $me" if eof($fh);
  157.  
  158.   seek($fh, tell($fh), 0);
  159.   my $data = [$config, $features, $auto_features];
  160.   $fh->print( 'do{ my '
  161.           . Data::Dumper->new([$data],['x'])->Purity(1)->Dump()
  162.           . '$x; }' );
  163.   truncate($fh, tell($fh));
  164.   $fh->close;
  165.  
  166.   chmod($mode_orig, $me)
  167.     or warn "Couldn't restore permissions on $me: $!";
  168. }
  169.  
  170. sub feature {
  171.   my ($package, $key) = @_;
  172.   return $features->{$key} if exists $features->{$key};
  173.   
  174.   my $info = $auto_features->{$key} or return 0;
  175.   
  176.   # Under perl 5.005, each(%%$foo) isn't working correctly when $foo
  177.   # was reanimated with Data::Dumper and eval().  Not sure why, but
  178.   # copying to a new hash seems to solve it.
  179.   my %%info = %%$info;
  180.   
  181.   require Module::Build;  # XXX should get rid of this
  182.   while (my ($type, $prereqs) = each %%info) {
  183.     next if $type eq 'description' || $type eq 'recommends';
  184.     
  185.     my %%p = %%$prereqs;  # Ditto here.
  186.     while (my ($modname, $spec) = each %%p) {
  187.       my $status = Module::Build->check_installed_status($modname, $spec);
  188.       if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
  189.     }
  190.   }
  191.   return 1;
  192. }
  193.  
  194. EOF
  195.  
  196.   my ($module_name, $notes_name) = ($args{module}, $args{config_module});
  197.   printf $fh <<"EOF", $notes_name, $module_name;
  198.  
  199. =head1 NAME
  200.  
  201. $notes_name - Configuration for $module_name
  202.  
  203.  
  204. =head1 SYNOPSIS
  205.  
  206.   use $notes_name;
  207.   \$value = $notes_name->config('foo');
  208.   \$value = $notes_name->feature('bar');
  209.   
  210.   \@names = $notes_name->config_names;
  211.   \@names = $notes_name->feature_names;
  212.   
  213.   $notes_name->set_config(foo => \$new_value);
  214.   $notes_name->set_feature(bar => \$new_value);
  215.   $notes_name->write;  # Save changes
  216.  
  217.  
  218. =head1 DESCRIPTION
  219.  
  220. This module holds the configuration data for the C<$module_name>
  221. module.  It also provides a programmatic interface for getting or
  222. setting that configuration data.  Note that in order to actually make
  223. changes, you'll have to have write access to the C<$notes_name>
  224. module, and you should attempt to understand the repercussions of your
  225. actions.
  226.  
  227.  
  228. =head1 METHODS
  229.  
  230. =over 4
  231.  
  232. =item config(\$name)
  233.  
  234. Given a string argument, returns the value of the configuration item
  235. by that name, or C<undef> if no such item exists.
  236.  
  237. =item feature(\$name)
  238.  
  239. Given a string argument, returns the value of the feature by that
  240. name, or C<undef> if no such feature exists.
  241.  
  242. =item set_config(\$name, \$value)
  243.  
  244. Sets the configuration item with the given name to the given value.
  245. The value may be any Perl scalar that will serialize correctly using
  246. C<Data::Dumper>.  This includes references, objects (usually), and
  247. complex data structures.  It probably does not include transient
  248. things like filehandles or sockets.
  249.  
  250. =item set_feature(\$name, \$value)
  251.  
  252. Sets the feature with the given name to the given boolean value.  The
  253. value will be converted to 0 or 1 automatically.
  254.  
  255. =item config_names()
  256.  
  257. Returns a list of all the names of config items currently defined in
  258. C<$notes_name>, or in scalar context the number of items.
  259.  
  260. =item feature_names()
  261.  
  262. Returns a list of all the names of features currently defined in
  263. C<$notes_name>, or in scalar context the number of features.
  264.  
  265. =item auto_feature_names()
  266.  
  267. Returns a list of all the names of features whose availability is
  268. dynamically determined, or in scalar context the number of such
  269. features.  Does not include such features that have later been set to
  270. a fixed value.
  271.  
  272. =item write()
  273.  
  274. Commits any changes from C<set_config()> and C<set_feature()> to disk.
  275. Requires write access to the C<$notes_name> module.
  276.  
  277. =back
  278.  
  279.  
  280. =head1 AUTHOR
  281.  
  282. C<$notes_name> was automatically created using C<Module::Build>.
  283. C<Module::Build> was written by Ken Williams, but he holds no
  284. authorship claim or copyright claim to the contents of C<$notes_name>.
  285.  
  286. =cut
  287.  
  288. __DATA__
  289.  
  290. EOF
  291.  
  292.   print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]);
  293. }
  294.  
  295. 1;
  296.